home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.006 / xemacs-1 / lib / xemacs-19.13 / lisp / ilisp / allegro.lisp next >
Encoding:
Text File  |  1995-01-26  |  2.5 KB  |  87 lines
  1. ;;; -*- Mode: Lisp -*-
  2.  
  3. ;;; allegro.lisp --
  4.  
  5. ;;; This file is part of ILISP.
  6. ;;; Version: 5.7
  7. ;;;
  8. ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
  9. ;;;               1993, 1994 Ivan Vasquez
  10. ;;;               1994, 1995 Marco Antoniotti and Rick Busdiecker
  11. ;;;
  12. ;;; Other authors' names for which this Copyright notice also holds
  13. ;;; may appear later in this file.
  14. ;;;
  15. ;;; Send mail to 'ilisp-request@lehman.com' to be included in the
  16. ;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP
  17. ;;; mailing list were bugs and improvements are discussed.
  18. ;;;
  19. ;;; ILISP is freely redistributable under the terms found in the file
  20. ;;; COPYING.
  21.  
  22. ;;;
  23. ;;; Allegro initializations
  24. ;;; Author: Chris McConnell, ccm@cs.cmu.edu
  25. ;;;
  26. (in-package "ILISP")
  27.  
  28. ;;;
  29. (defun ilisp-callers (symbol package)
  30.   "Print a list of all of the functions that call FUNCTION and return
  31. T if successful." 
  32.   (ilisp-errors
  33.    (let ((function (ilisp-find-symbol symbol package))
  34.      (callers nil)
  35.      (*print-level* nil)
  36.      (*print-length* nil)
  37.      (*package* (find-package 'lisp)))
  38.      (when (and function (fboundp function))
  39.        (labels ((in-expression (function expression)
  40.           (cond ((null expression) nil)
  41.             ((listp expression)
  42.              (let ((header (first expression)))
  43.                (if (or (eq header function)
  44.                    (and (eq header 'function)
  45.                     (eq (second expression) function)))
  46.                    t
  47.                    (dolist (subexp expression)
  48.                  (when (in-expression function subexp)
  49.                    (return t)))))))))
  50.      (excl::who-references
  51.       function
  52.       #'(lambda (function)
  53.           (push (excl::fn_symdef function) callers)))
  54.      (do-all-symbols (symbol)
  55.        (when (and (fboundp symbol)
  56.               (not (compiled-function-p (symbol-function symbol)))
  57.               (in-expression function (symbol-function symbol)))
  58.          (push symbol callers)))
  59.      (dolist (caller callers)
  60.        (print caller))
  61.      t)))))
  62.  
  63. ;;;
  64. (defun ilisp-source-files (symbol package type)
  65.   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  66. return T if successful."
  67.   (ilisp-errors
  68.    (let* ((symbol (ilisp-find-symbol symbol package))
  69.       (type (if (equal type "any") t (ilisp-find-symbol type "keyword")))
  70.       (paths (when symbol (excl:source-file symbol type))))
  71.      (if paths
  72.      (progn
  73.        (if (eq type t)
  74.            (dolist (path (remove-duplicates paths
  75.                         :key #'cdr :test #'equal))
  76.          (print (namestring (cdr path))))
  77.            (print (namestring paths)))
  78.        t)
  79.      nil))))
  80.  
  81. ;;;
  82. (dolist (symbol '(ilisp-callers ilisp-source-files))
  83.   (export symbol))
  84. (unless (compiled-function-p #'ilisp-callers)
  85.   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  86.  
  87.